Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-04/bipl.zip/PROGS.ZIP/CROSS.ICN

Text File | 1992-09-28 | 5KB | 193 lines

############################################################################
#
#    File:     cross.icn
#
#    Subject:  Program to display intersection of words
#
#    Author:   William P. Malloy
#
#    Date:     June 10, 1988
#
###########################################################################
#
#     This program takes a list of words and tries to arrange them
#  in cross-word format so that they intersect. Uppercase letters
#  are mapped into lowercase letters on input.  For example, the
#  input
#
#          and
#          eggplants
#          elephants
#          purple
#
#  produces the output
#       +---------+
#       | p       |
#       | u e     |
#       | r g     |
#       | p g     |
#       |elephants|
#       | e l     |
#       |   and   |
#       |   n     |
#       |   t     |
#       |   s     |
#       +---------+
#
#  Diagnostics: The program objects if the input contains a nonal-
#  phabetic character.
#
#  Comments: This program produces only one possible intersection
#  and it does not attempt to produce the most compact result.  The
#  program is not very fast, either.  There is a lot of room for
#  improvement here. In particular, it is natural for Icon to gen-
#  erate a sequence of solutions.
#
############################################################################

global fast, place, array, csave, fsave, number

procedure main()
   local words, nonletter, line
   nonletter := ~&letters
   words := []

   while line := map(read()) do
      if upto(nonletter,line) then stop("input contains nonletter")
      else put(words,line)
   number := *words
   kross(words)

end

procedure kross(words)
   local one, tst, t
   array := [get(words)]
   t := 0
   while one := get(words) do {
      tst := *words
      if fit(one,array,0 | 1) then
     t := 0
      else {
     t +:= 1
         put(words,one)
     if t > tst then
        break
     }
      }
   if *words = 0 then Print(array)
   else write(&errout,"cannot construct puzzle")
end

procedure fit(word,matrix,where)
   local i, j, k, l, one, test, t, s
   s := *matrix
   t := *matrix[1]
   every k := gen(*word) do
      every i := gen(s) do
         every j := gen(t) do
        if matrix[i][j] == word[k] then {
               # test for vertical fit
               if where = 0 then {
                  test := 0
                  every l := (i - k + 1) to (i + (*word - k)) do
                     if tstv(matrix,i,j,l,s,t) then {
                        test := 1
                        break
                        }
                  if test = 0 then
                     return putvert(matrix,word,i,j,k)
                  }
               if where = 1 then {
                  test := 0
                  every l := (j - k + 1) to (j + (*word - k)) do
                     if tsth(matrix,i,j,l,s,t) then {
                        test := 1
                        break
                        }
                  if test = 0 then
                     return puthoriz(matrix,word,i,j,k)
                  }
               }
end

procedure tstv(matrix,i,j,l,s,t)
   return ((matrix[(l ~= i) & (s >= l) & (0 < l)][0 < j-1] ~== " ") |
      (matrix[(l ~= i) & (s >= l) & (0 < l)][t >= j + 1] ~== " ") |
      (matrix[(i ~= l-1) & (s >= l-1) & (0 < l-1)][j] ~== " ") |
      (matrix[(i ~= l + 1) & (s >= l+1) & (0 < l + 1)][j] ~== " ") |
      (matrix[(l ~= i) & (s >= l) & (0 < l)][j] ~== " "))
end

procedure tsth(matrix,i,j,l,s,t)
   return ((matrix[0 < i-1][(l ~= j) & (t >= l) & (0 < l)] ~== " ") |
      (matrix[s >= i + 1][(l ~= j) & (t >= l) & (0 < l)] ~== " ") |
      (matrix[i][(j ~= l-1) & (t >= l-1) & (0 < l-1)] ~== " ") |
      (matrix[i][(j ~= l + 1) & (t >= l + 1) & (0 < l + 1)] ~== " ") |
      (matrix[i][(l ~= j) & (t >= l) & (0 < l)] ~== " "))
end

procedure gen(i)
   local tmp, up, down
   tmp := i / 2
   if (i % 2) = 1 then
      tmp +:= 1
   suspend tmp
   up := tmp
   down := tmp
   while (up < i) do {
      suspend up +:= 1
      suspend (down > 1) & (down -:= 1)
      }
end

# put `word' in vertically at pos(i,j)

procedure putvert(matrix,word,i,j,k)
   local hdim, vdim, up, down, l, m, n
   vdim := *matrix
   hdim := *matrix[1]
   up := 0
   down := 0
   up := abs(0 > (i - k))
   down := abs(0 > ((vdim - i) - (*word - k)))
   every m := 1 to up do
      push(matrix,repl(" ",hdim))
   i +:= up
   every m := 1 to down do
      put(matrix,repl(" ",hdim))
   every l := 1 to *word do
      matrix[i + l - k][j] := word[l]
   return matrix
end

# put `word' in horizontally at position i,j in matrix

procedure puthoriz(matrix,word,i,j,k)
   local hdim, vdim, left, right, l, m, n
   vdim := *matrix
   hdim := *matrix[1]
   left := 0
   right := 0
   left := (abs(0 > (j - k))) | 0
   right := (abs(0 > ((hdim - j) - (*word - k)))) | 0
   every m := 1 to left do
      every l := 1 to vdim do
       matrix[l] := " " || matrix[l]
   j +:= left
   every m := 1 to right do
      every l := 1 to vdim do
      matrix[l] ||:= " "
   every l := 1 to *word do
      matrix[i][j + l - k] := word[l]
   return matrix
end

procedure Print(matrix)
   local i
   write("+",repl("-",*matrix[1]),"+")
   every i := 1 to *matrix do
      write("|",matrix[i],"|")
   write("+",repl("-",*matrix[1]),"+")
end